;;; This is a template for defining any Meta(Lang) major mode.
;;;   Refer to
;;;      http://two-wugs.net/emacs/mode-tutorial.html
;;;   for an excellent tutorial on major-mode creation.
;;;   This code is a simple translation of that website content
;;;   to handle Meta.
;;;
;;; There are only two things that need to be done to instantiate this
;;; template as a real major-mode file:
;;;   1) Replace
;;;        <CONSTRUCTS-HERE>     with the list of construct names (each name delimited by "")
;;;        <ATTRIBUTE-KEYS-HERE> with the list of non-primary attribute keys (each key delimited by "")
;;;        <FEATURE-VALUES-HERE> with the list of feature values (each value delimited by "")
;;;   2) Replace 'metalang' with the appropriate language-specific name
;;;      (for example, 'meta' or 'metaoopl' for Meta(Oopl), 'metadoc' for Meta(Doc),
;;;      metainstall for 'Meta(Install)', etc.
;;;
;;; IMPORTANT:
;;;   If the line after this paragraph does NOT contain the words
;;;   'MetaLang' and 'metalang', then you are currently looking at an
;;;   instantiation of the template, not the template itself!
 ;;
 ;;      This is the file for Meta(Oopl) with suffix .metaoopl
 ;;
;;; Due to the structure of Meta, a basic major-mode is very easy to create,
;;; having few rules:
;;;
;;;   1) Each line is indented a certain number of spaces further
;;;      than the closest previous line that ends with '{'.
;;;
;;;   2) Since every construct consists of key/value pairs,
;;;      and we know the strings that represent keys (and, in the case
;;;      of feature attributes, the strings that represent values),
;;;      we can easily provide coloring of the various syntactic elements.
;;;
;;;   3) Text within simple blocks becomes somewhat more difficult to
;;;      deal with.  For example, METHOD SCOPE blocks should be using
;;;      the statement-level code from the appropriate base-language
;;;      major-mode, while COMMENT blocks should be colored in the
;;;      comment color, etc.
;;;
;;; With respect to indentation, a simple algorithm is:
;;;   1) If we are at the beginning of the buffer, indent to column 0.
;;;   2) If we are currently at a line starting with '}', then
;;;      de-indent relative to the previous line.  However, if the
;;;      previous line starts a block, indent to the same level.
;;;   3) If we first see a line ending with '{' then we need to increase
;;;      our indentation relative to that line.
;;;   4) If we first see an '}' line before our current line, then we should
;;;      indent our current line to the same indentation as the '}' line.
;;;      NOTE: It is important to check for rule 3 before rule 4 (and the
;;;            ordered is reversed from the tutorial) because in Meta
;;;            it is possible to end one block and start another on the same
;;;            line.
;;;   5) If none of the above apply, then do not indent at all.
;;;
;;;   However, the above algorithm really is too simple.  To make it
;;;   more powerful, the algorithm should be extended to recognize
;;;   which block-valued attribute the current line is contained
;;;   within, and only perform the above indentation of that attribute
;;;   value is complex.  If simple, each line should be indented at
;;;   least metaoopl-indent-offset more than the start-of-block line, but
;;;   if the line already has more indentation than that, it should be
;;;   left as-is.
;;;
;;; With respect to coloring, a simple set of rules is:
;;;   1) All construct names are colored with font-lock-metaoopl-construct-face
;;;   2) All attribute keys are colored with font-lock-metaoopl-attribute-key-face
;;;   3) All feature values are colored with font-lock-metaoopl-feature-value-face
;;;
;;;   However, this must be extended significantly.
;;;
;;;     - must handle COMMENT { ... } sequences, and the tutorial
;;;       doesn't address the issue of comment sequences longer than
;;;       2 characters.  Looking at the Emacs-Lisp major-mode will
;;;       help us with 3 characters (which might allow us to generalize).
;;;       Also, looking at the lisp documentation for Syntax Descriptors
;;;       linked from the tutorial.
;;;
;;;     - Cannot currently highlight non-alphanumeric sequences.  For
;;;       example, TITLE can be highlighted, but ':' cannot be.  Why is this?
;;;
;;;     - Would be useful to color the identifier of each construct,
;;;       and maybe even give each attribute-key an
;;;       attribute-value-type-specific color (i.e. 'id' and 'word'
;;;       types colors one thing, 'str' colored another, 'id-list' and
;;;       'word-list' colored another, simple blocks colored another
;;;       and complex blocks colored yet another.
;;;
;;; Overlays and Extents
;;;   Emacs and XEmacs provide some truly powerful mechanisms for providing
;;;   hierarchial views of programs that are very well suited to Meta syntax.
;;;
;;;   In particular, Emacs provides the concept of overlays, which
;;;   allows one to associated textual properties with a range of
;;;   characters.  This includes assigning colors and fonts, making
;;;   the text invisible, providing an overriding or extending keymap,
;;;   etc. etc.  I suspect that this support is provided at a very low
;;;   level and is thus very efficient, and it opens the door to some
;;;   truly wonderful capabilities.  XEmacs provides similar support,
;;;   but unfortunately uses a different mechanism (not overlays, but
;;;   rather extents).  It sounds like extents are probably more
;;;   powerful than overlays (combining in one environment both Emacs
;;;   overlays and Emacs text properties).  There are also claims that
;;;   XEmacs supports the Emacs overlay interface (and implements the
;;;   interface using extents).  However, this does not appear to be true
;;;   in XEmacs 21.4 (the various overlay-related functions do not exist).
;;;   I did encounter an abstraction API that introduces the concept of a 'span'
;;;   and implements a common span interface using either overlays (for Emacs)
;;;   or extents (for XEmacs).  See http://proofgeneral.inf.ed.ac.uk/components.
;;;   I may reimplement the following code to use span.el, but this would require
;;;   that we provide span.el in Meta.  Hopefully there is a cleaner approach
;;;   (if we can find out how to provide the overlay interface in XEmacs).  For
;;;   now, this code does not work in XEmacs.
;;;
;;;   The idea behind the overlay implementation is to create an overlay
;;;   for every meta-level block.  These overlays can be used for various
;;;   purposes:
;;;    - coloring a block to show its extent
;;;    - collapsing the block (making its text invisible)
;;;    - establishing a region on which base-language-specific fontification
;;;      can be applied
;;;
;;;   Some notes about the overlay implementation:
;;;    - When the region marked by an overlay is made invisible, by default
;;;      the text is still visible to cursor movement commands (but not searching
;;;      commands).
;;;       - searching commands ignore invisible text (by default, or did I do something?)
;;;       - line movement commands can be told to ignore invisible text
;;;         by setting the 'line-move-ignore-invisible variable to true.
;;;       - cursor movement commands cannot be ignored like line-movement
;;;         commands, but overlays can have a keymap associated with them,
;;;         so the meta overlay code provides a keymap that redefines
;;;         C-f and C-b so that they jump to the end and start of the invisible
;;;         region respectively.
;;;    - When text is made invisible, it is possible to insert arbitrary
;;;      visual text at the start and/or end of the region
;;;       - this text is not "real", does not affect searches, movement,
;;;         column counts, etc.  - it is solely a visual cue.
;;;       - initial implementations of the invisibility code made an overlay
;;;         starting on a '{' and ending on a '}', and, when the region was
;;;         made invisible, inserted the marker text '{...}'.  However, this
;;;         is problematic because searches for '{' or '}' then ignore the
;;;         entire block (remember that marker text is not real, so the '{'
;;;         and '}' in the '{...}' marker text is not seen by searches).
;;;       - a better approach creates an overlay for the region from one character
;;;         after the '{' to one character before the '}' and provides marker
;;;         text '...'.
;;;           - the disadvantage of this strategy is that an individual can
;;;             move to a '{' containing subsequent invisible text, move
;;;             forward one character (so the cursor is now "inside" the invisible
;;;             text, but not yet using the overlay keymap...

;;; **************************************************************
;;; Meta Language Specific variables
;;;   - The values of these variables differ for each particular Meta language
;;;     (but not each Meta sub-language)

(defconst metaoopl-constructs     '("Attribute" "Construct" "File" "Schema" "accessor" "assoc" "category" "class" "field" "initializer" "method" "namespace" "native" "remark" "var"))
(defconst metaoopl-attribute-keys '("#" ":" ":#" "::" ":=" "=" "abbrev" "abbrevs" "associations" "assocs" "children" "clinit" "comment" "compile" "condef" "config" "coverage" "decl" "default" "defn" "delegate" "dispatch" "extends" "file" "flags" "implements" "implicit" "import" "imports" "indent" "inheritance" "init" "key" "kind" "level" "limit" "location" "metaclass" "mock" "multiplicity" "mutability" "nature" "order" "padding" "parameter" "params" "pargs" "position" "post" "pre" "prefix" "preinit" "presence" "priority" "requires" "returns" "returns_" "run" "scope" "select" "singular" "span" "special" "status" "template" "test" "testparent" "tests" "throws" "type" "uniqueness" "value" "visibility" "within"))
(defconst metaoopl-feature-values '("abbrevkey" "abstract" "autodispatch" "autoin" "baselang" "cls" "code" "codetest" "concrete" "const" "covgen" "critical" "decl" "defn" "feature" "final" "general" "get" "getref" "getset" "getsetref" "immutable" "inline" "inner" "instance" "internal" "interned" "k_normal" "leaf" "lib" "limited" "major" "medium" "meta" "minor" "multi" "multibaselang" "mutable" "no_extend" "nokey" "nonvirtual" "noparam" "normal" "noval" "optional" "override" "pad_after" "pad_around" "pad_before" "pad_none" "post_decl" "post_extend" "pre_decl" "pre_extend" "primary" "private" "protected" "pubget" "public" "raw" "ref" "required" "root" "secondary" "separate" "set" "setref" "showkey" "showval" "singleton" "specific" "static" "stdlib" "sub_extend" "super_extend" "top" "undef" "unique" "unittest" "unsafe" "userval" "vararg" "virtual"))
(defconst metaoopl-keywords       '("complex" "end" "id" "id-list" "int" "real" "simple" "str" "type" "word" "word-list" "xid"))
(defconst metaoopl-basewords      '("BEGIN" "CHECK" "CORE" "DESTROY" "END" "INIT" "UNITCHECK" "__DATA__" "__END__" "__FILE__" "__LINE__" "__PACKAGE__" "abs" "abstract" "accept" "alarm" "alignas" "alignof" "and" "and_eq" "as" "asm" "assert" "atan2" "auto" "bind" "binmode" "bitand" "bitor" "bless" "bool" "boolean" "break" "byte" "caller" "case" "catch" "char" "char16_t" "char32_t" "chdir" "chmod" "chomp" "chop" "chown" "chr" "chroot" "class" "close" "closedir" "cmp" "compl" "connect" "const" "const_cast" "constexpr" "continue" "cos" "crypt" "dbmclose" "dbmopen" "debugger" "decltype" "def" "default" "defined" "del" "delete" "die" "do" "double" "dump" "dynamic_cast" "each" "elif" "else" "elsif" "endgrent" "endhostent" "endnetent" "endprotoent" "endpwent" "endservent" "enum" "eof" "eq" "eval" "except" "exec" "exists" "exit" "exp" "explicit" "export" "extends" "extern" "false" "fcntl" "fileno" "final" "finally" "float" "flock" "for" "foreach" "fork" "format" "formline" "friend" "from" "function" "ge" "getc" "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" "getservbyname" "getservbyport" "getservent" "getsockname" "getsockopt" "glob" "global" "gmtime" "goto" "grep" "gt" "hex" "if" "implements" "import" "in" "index" "inline" "instanceof" "int" "interface" "ioctl" "is" "join" "keys" "kill" "lambda" "last" "lc" "lcfirst" "le" "length" "let" "link" "listen" "local" "localtime" "lock" "log" "long" "lstat" "lt" "m" "map" "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "mutable" "my" "namespace" "native" "ne" "new" "next" "no" "noexcept" "not" "not_eq" "nullptr" "oct" "open" "opendir" "operator" "or" "or_eq" "ord" "our" "pack" "package" "pass" "pipe" "pop" "pos" "print" "printf" "private" "protected" "prototype" "public" "push" "q" "qq" "qr" "quotemeta" "qw" "qx" "raise" "rand" "read" "readdir" "readline" "readlink" "readpipe" "recv" "redo" "ref" "register" "reinterpret_cast" "rename" "require" "reset" "return" "reverse" "rewinddir" "rindex" "rmdir" "s" "say" "scalar" "seek" "seekdir" "select" "semctl" "semget" "semop" "send" "setgrent" "sethostent" "setnetent	" "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" "setsockopt" "shift" "shmctl" "shmget" "shmread" "shmwrite" "short" "shutdown" "signed" "sin" "sizeof" "sleep" "socket" "socketpair" "sort" "splice" "split" "sprintf" "sqrt" "srand" "stat" "state" "static" "static_assert" "static_cast" "strictfp" "struct" "study" "sub" "substr" "super" "switch" "symlink" "synchronized" "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" "telldir" "template" "this" "thread_local" "throw" "throws" "tie" "tied" "time" "times" "tr" "transient" "true" "truncate" "try" "typedef" "typeid" "typename" "typeof" "uc" "ucfirst" "umask" "undef" "union" "unless" "unlink" "unpack" "unshift" "unsigned" "untie" "until" "use" "using" "utime" "values" "var" "vec" "virtual" "void" "volatile" "wait" "waitpid" "wantarray" "warn" "wchar_t" "while" "with" "write" "xor" "xor_eq" "yAUTOLOAD" "yield"))

(defconst metaoopl-constructs-re     (regexp-opt metaoopl-constructs t))
(defconst metaoopl-attribute-keys-re (regexp-opt metaoopl-attribute-keys t))
(defconst metaoopl-feature-values-re (regexp-opt metaoopl-feature-values t))
(defconst metaoopl-keywords-re       (regexp-opt metaoopl-keywords t))
(defconst metaoopl-basewords-re      (regexp-opt metaoopl-basewords t))

;;; **************************************************************
;; Service routines
(defun metaoopl-set-face (face foreground background font)
  (interactive "sFace: \nsForeground: \nsBackground: \n Font: ")

  (let ( (res (facep face)) )
      (if (not res) (setq res (make-face face)))
      (if foreground (set-face-foreground face foreground))
      (if background (set-face-background face background))
      (if font (set-face-font face font))
      ; for whatever reason, most font-lock face names are sometimes
      ; used as variables, not symbols, so we make sure that the
      ; variable for symbol 'face' is bound to 'face'.
      (set face face)
      res
  )
)

;;; **************************************************************
;;; User customization:

;; Users can call 'metaoopl-set-face' to customize the colors
;; used for Meta programs. See http://raebear.net/comp/emacscolors.html
;; for a useful way to view background and foreground colors together.
(metaoopl-set-face 'font-lock-metaoopl-construct-face      "red"       nil  "6x13")
(metaoopl-set-face 'font-lock-metaoopl-attribute-key-face  "blue"      nil  "6x13")
(metaoopl-set-face 'font-lock-metaoopl-feature-value-face  "darkgreen" nil  "6x13")
(metaoopl-set-face 'font-lock-metaoopl-keyword-face        "deep pink"   nil  "6x13")
(metaoopl-set-face 'font-lock-metaoopl-baseword-face       "purple"    nil  "6x13")

;; Users can define 'metaoopl-mode-hook' to get special functionality
;; when this mode is invoked.
(defvar metaoopl-mode-hook nil
  ""
)

;; Users can specify the indentation at each level
(defvar metaoopl-indent-offset 2
  "The amount of indentation to add to lines within a scope block.  It
is also currently used for indentation within '(' ')' lists but this
will be generalized later.")

(defvar metaoopl-wrap-collapsed-block-ends t
  "When a block attribute value is collapsed, the attribute that
appears next will by default appear on the same line, which makes for
very long single lines for fully collapsed constructs.  To address this,
it is possible to insert a newline and indentation in the collapsed-block
indication string so that the next attribute appears to reside on the
next line at the proper indentation level.  If this variable is true,
such newline-indentation is provided.")
;:TEMP
(setq metaoopl-wrap-collapsed-block-ends t)
;:ENDTEMP

(defun metaoopl-make-map ()
  (let ((metaoopl-mode-map (make-keymap))
	(space-map (make-sparse-keymap))
	)
    ;; Add key bindings here
    (define-key metaoopl-mode-map "\C-j" 'newline-and-indent)

    ;; Iniital bindings for \C-@
    ;;   some emacs versions don't bind \C-@ to Ctrl space, so we
    ;;   do both
    (define-key metaoopl-mode-map [?\C-\ ] space-map)
    (define-key metaoopl-mode-map "\C-@" space-map)
    (define-key space-map [?\C-\ ] 'set-mark-command)
    (define-key space-map "\C-@" 'set-mark-command)

    ;; Add \C-@ key bindings here
    

    (define-key space-map [(control \,)] 'meta-toggle-prev-overlay-color)
    (define-key space-map [(control \.)] 'meta-toggle-next-overlay-color)
    (define-key space-map [(control \<)] 'meta-toggle-prev-overlay-visibility)
    (define-key space-map [(control \>)] 'meta-toggle-next-overlay-visibility)
    (define-key space-map "ro" 'meta-remove-all-overlays)
    (define-key space-map "vm" (lambda () (interactive) (find-file (concat (getenv "META_ROOT") "/root/lib/emacs/metaoopl-mode.el"))))
    (define-key space-map "lm" (lambda () (interactive) (load-file (concat (getenv "META_ROOT") "/root/lib/emacs/metaoopl-mode.el"))))

    ; construct-related macros
    (define-key space-map "mc" 'metaoopl-complete-construct)  ; intentional metaoopl
    (define-key space-map "cm" 'metaoopl-complete-construct)  ; intentional metaoopl
    (define-key space-map "b<" 'meta-parent-block)

    (define-key space-map "c<" 'meta-construct-beginning)
    (define-key space-map "c>" 'meta-construct-end)
    (define-key space-map "c." 'meta-collapse-construct)
    (define-key metaoopl-mode-map [(control \,)] 'meta-toggle-prev-overlay-color)
    (define-key metaoopl-mode-map [(control \.)] 'meta-toggle-next-overlay-color)
    (define-key metaoopl-mode-map [(control \<)] 'meta-toggle-prev-overlay-visibility)
    (define-key metaoopl-mode-map [(control \>)] 'meta-toggle-next-overlay-visibility)

    ; Paragraph modifying functions
    (define-key space-map "pa" '(lambda (prefix) (interactive "p") (let ((s (region-beginning)) (e (region-end)) d) (goto-char s) (insert "[++===") (setq d (- (point) 3)) (goto-char (+ e 6)) (insert "--]") (goto-char d))))
    (define-key space-map "pd" '(lambda () (interactive) (let (p) (re-search-forward "\\[\\+\\+" nil) (forward-char -3) (delete-char 3) (re-search-forward "===" nil)  (forward-char -3) (setq p (point)) (re-search-forward "--\\]") (delete-region p (point)) )))
    (define-key space-map "pu" '(lambda () (interactive) (let (p) (re-search-forward "\\[\\+\\+" nil) (forward-char -3) (setq p (point)) (re-search-forward "===" nil)  (delete-region p (point)) (re-search-forward "--\\]") (delete-region (- (point) 3) (point)))))

    ; return the map!
    metaoopl-mode-map
    )
)

;; We establish the map
(setq metaoopl-mode-map
;;(defvar metaoopl-mode-map
   (metaoopl-make-map)
   ;;"Keymap for Meta major mode"
)

;; Establish a file-suffix to mode mapping
(add-to-list 'auto-mode-alist '("\\.metaoopl" . metaoopl-mode))
(add-to-list 'auto-mode-alist '("\\.metaschema" . metaoopl-mode))

;; Define some variables reprsenting the font-lock regexps.
;; These use the metaoopl-language-specific variables defined above.
(defconst metaoopl-font-lock-keywords-1
  (list
    (cons (concat "\\<" metaoopl-constructs-re     "\\>") font-lock-metaoopl-construct-face)
    (cons (concat "\\<" metaoopl-attribute-keys-re "\\>") font-lock-metaoopl-attribute-key-face)
    (cons (concat "\\<" metaoopl-feature-values-re "\\>") font-lock-metaoopl-feature-value-face)
  )
  "Highlighting of Meta code"
)

(defconst metaoopl-font-lock-keywords-2
  (append metaoopl-font-lock-keywords-1
     (list
        ;; '("somestring" . font-lock-constant-face)
        (cons (concat "\\<" metaoopl-keywords-re "\\>") font-lock-metaoopl-keyword-face)
     )
  )
)

(defconst metaoopl-font-lock-keywords-3
  (append metaoopl-font-lock-keywords-2
     (list
        ;; '("somestring" . font-lock-constant-face)
        (cons (concat "\\<" metaoopl-basewords-re "\\>") font-lock-metaoopl-baseword-face)
     )
  )
)

(defvar metaoopl-font-lock-keywords metaoopl-font-lock-keywords-3
  "Default highlighting expressions for Meta mode")
; TEMPORARY - so that changes in constants above will be reflected on reload
(setq metaoopl-font-lock-keywords metaoopl-font-lock-keywords-3)
; ETEMP

;; We define the syntax table for Meta
;;  First, '-', '_' and '.' are all considered parts of words
;;  Second, we currently define C++-style comment syntax, but will
;;    need to determine how to define COMMENT { ... } as a comment.
;;(defvar metaoopl-mode-syntax-table
(setq metaoopl-mode-syntax-table
  (let ((metaoopl-mode-syntax-table (make-syntax-table)))

    (modify-syntax-entry ?- "w" metaoopl-mode-syntax-table)
    (modify-syntax-entry ?_ "w" metaoopl-mode-syntax-table)
    (modify-syntax-entry ?. "w" metaoopl-mode-syntax-table)

    ;; This gives C++-style comments (/* ... */ and //)
    ;; Do not yet know how to treat COMMENT { ... } as a comment
    ;;;;;(modify-syntax-entry ?/  ". 124b" metaoopl-mode-syntax-table)
    ;;;;;(modify-syntax-entry ?*  ". 23" metaoopl-mode-syntax-table)
    ;;;;;(modify-syntax-entry ?\n "> b" metaoopl-mode-syntax-table)
    ;; This gives perl-style comments ('#').
    ;;;;;(modify-syntax-entry ?#  "< b" metaoopl-mode-syntax-table)
    ;; We need to extend this to provide meta-style comments ('/#')
    ;; but I do not yet know how to do this while still providing
    ;; perl-style comments.

    ;; This gives Meta-style comments --> /#
    (cond
     (( string-match "XEmacs\||Lucid" emacs-version)

      )
     (t
      (modify-syntax-entry ?/  ". 14" metaoopl-mode-syntax-table)
      (modify-syntax-entry ?#  ". 2b" metaoopl-mode-syntax-table)
      ;(modify-syntax-entry ?\n "> a" metaoopl-mode-syntax-table)
      (modify-syntax-entry ?\n "> b" metaoopl-mode-syntax-table)

      ;; This adds in C-style multiline comments --> /* ... */
      ;; (modify-syntax-entry ?*  ". 23" metaoopl-mode-syntax-table)
      )
     )
    metaoopl-mode-syntax-table
  )
  ;;"Syntax table for metaoopl-mode"
)

;; This method indents the current line as Meta code
(defun metaoopl-indent-line ()
   "Indent current line as Meta code"
   (interactive)
   (beginning-of-line)

   ;;;   1) If we are at the beginning of the buffer, indent to column 0.
   ;;;   2) If we are currently at a line starting with '}', then
   ;;;      de-indent relative to the previous non-blank line.  However, if the
   ;;;      previous line starts a block, indent to the same level.
   ;;;   2b) Same applies for ')' as for '}'
   ;;;   3) If we first see a line ending with '{' then we need to increase
   ;;;      our indentation relative to that line.
   ;;;   3b) Same applies for '(' as for '{'
   ;;;   3b) Same applies for ':' as for '{'  (to support python)
   ;;;   4) If we first see an '}' line before our current line, then we should
   ;;;      indent our current line to the same indentation as the '}' line.
   ;;;      NOTE: It is important to check for rule 3 before rule 4 (and the
   ;;;            ordered is reversed from the tutorial) because in Meta
   ;;;            it is possible to end one block and start another on the same
   ;;;            line.
   ;;;   4b) Same applies for ')' as for '}'
   ;;;   5) If line has a '(' but no matching ')', indent one space past '('
   ;;;   5b) If line ends in ')', find line that has matching start paren
   ;;;       and indent to the same level as that line.
   ;;;   6) If none of the above apply, then indent at same level as closes
   ;;;      non-empty line above point.

   ; Check for rule 1
   (if (bobp)
      (let ()
        (indent-line-to 0)
        (message "Rule 1")
      )
   ; else
      (let ((not-indented t) cur-indent)
	(cond
	 ( (looking-at "^[ \t]*}") ; Check for rule 2
           (save-excursion
             (message "Rule 2")
             (forward-line -1)
	     (while (looking-at "^[ \t]*$") (forward-line -1))
	     (if (looking-at ".*{[ \t]*$")
	       (setq cur-indent (meta-current-indentation))
	       (setq cur-indent (- (meta-current-indentation) metaoopl-indent-offset))
	     )
	     (if (< cur-indent 0) (setq cur-indent 0)))
	   )

	 ( (looking-at "^[ \t]*)") ; Check for rule 2
           (save-excursion
             (message "Rule 2")
             (forward-line -1)
	     (while (looking-at "^[ \t]*$") (forward-line -1))
	     (if (looking-at ".*([ \t]*$")
      	       (setq cur-indent (meta-current-indentation))
	       (setq cur-indent (- (meta-current-indentation) metaoopl-indent-offset))
	     )
	     (if (< cur-indent 0) (setq cur-indent 0)))
	   )
	 (t
         ;;; else
	 ;;;   We search upwards from the current line until we find some
	 ;;;   indication of how to indent the current line.
	  (save-excursion
            (while not-indented
              (forward-line -1)
	      (while (looking-at "^[ \t]*$")
		(forward-line -1))
	      (cond
	        ;; If looking at a comment line, indent to same level as comment
	        ((looking-at "^\\([ \t]*\\)/#")
		 (message "Comment Rule")
		 (setq cur-indent (- (match-end 1) (match-beginning 1)))
		 (setq not-indented nil))

	        ;; Check for rule 3
	        ((looking-at ".*{[ \t]*$")
		 (message "Rule 3")
		 (setq cur-indent (+ (meta-current-indentation) metaoopl-indent-offset))
		 (setq not-indented nil))

		;; Check for rule 3b
	        ((looking-at ".*([ \t]*$")
		 (message "Rule 3b")
		 (setq cur-indent (+ (meta-current-indentation) metaoopl-indent-offset))
		 (setq not-indented nil))

		;; Check for rule 3c
	        ((and (looking-at ".*:[ \t]*$") (not (looking-at "^[ \t]*\/\#")))
		 (message "Rule 3c")
		 (setq cur-indent (+ (meta-current-indentation) metaoopl-indent-offset))
		 (setq not-indented nil))

	        ;; Check for rule 4
		((looking-at "^[ \t]*}")
		 (message "Rule 4")
		 (setq cur-indent (meta-current-indentation))
		 (setq not-indented nil))

		;; Check for rule 4
		((looking-at "^[ \t]*)")
		 (message "Rule 4b")
		 (setq cur-indent (meta-current-indentation))
		 (setq not-indented nil))

		;; Check for rule 5 - non-matching open-paren
		((looking-at "\\(.*(\\)[^)]*$")
		 (message "Rule 5")
		 (setq cur-indent (- (match-end 1) (match-beginning 1)))
		 (setq not-indented nil))

		;; Check for rule 5b - line ends in ')'
		((looking-at ".*)[ \t]*$")
		   (message "Rule 5b")
		   ; TODO(wmh): cannot believe that blink-matching-open isn't
		   ; decomposed into a self-contained function that finds the
		   ; position of the matching paren.  Must make this code mor
		   ; general, as it is not guaranteed to find the matching
		   ; open paren.
		   (while not-indented
		     (cond
		       ((looking-at "^\\([ \t]*\\).*(")
			(setq cur-indent (- (match-end 1) (match-beginning 1)))
			(setq not-indented nil)
			)
		       (t
			(forward-line -1)
		       ))))

		;; Check for rule 6
		(t
		 (setq cur-indent (meta-current-indentation))
		 (setq not-indented nil))

		)))
          ))

          (if cur-indent
             (indent-line-to cur-indent)
          ;; else
          ;;   we didn't see an indentation hint, so allow no indentation
             (indent-line-to 0)
          )
      )
   )
)

(defun insert-lines-indented (list)
   "Insert the list of lines given into the current buffer, indenting
    each line as it is inserted.  There should NOT be newline characters
    within any of the strings in the list. "
    (if (null list)
       (let ())
       (insert (car list))
       (metaoopl-indent-line)
       (end-of-line)
       (insert "\n")
       (insert-lines-indented (cdr list))
    )
)

(defun insert-construct (ctype &optional id)
   (interactive "sConstruct: \nsName:")

   (let ((str (if (null id) "" (concat " " id))))

     ;; Insert construct start at correct indentation
     (metaoopl-indent-line)
     (insert (concat ctype str " {\n"))

     ;; Insert (empty) one line within the SCOPE
     (metaoopl-indent-line)
     (insert "\n")

     ;; Insert the end-of-construct line
     (insert (concat "} " (downcase ctype) str ";\n"))
     (next-line -1)
     (metaoopl-indent-line)

     ;; Move back up to original line and position cursor
     ;; after the construct primary key/value.
     (next-line -2)
     (end-of-line)
     (forward-char -2)
  )
)

;; The mode method
(defun metaoopl-mode ()
  "Major mode for editing Meta(Oopl) language files"
  (interactive)
  (kill-all-local-variables)
  (set-syntax-table metaoopl-mode-syntax-table)

  ;; We explicitly set the map here so that each time the mode
  ;; entry function is called we recompute - this is temporary
  ;; until the meta modes are stable (after which the setq
  ;; line can be removed for efficiency)
  (setq metaoopl-mode-map (metaoopl-make-map))
  (use-local-map metaoopl-mode-map)

  (set (make-local-variable 'font-lock-defaults) '(metaoopl-font-lock-keywords))
  (set (make-local-variable 'indent-line-function) 'metaoopl-indent-line)
  (set (make-local-variable 'parse-sexp-ignore-comments) t)

  ;; This sets up comment info
  (set (make-local-variable 'comment-start) "/#")
  (set (make-local-variable 'comment-style) 'multi-line)

; TODO: These are commented out to disable overlays until we get them working in both
; emacs and xemacs!
;  (meta-prepare-overlays)
;  (meta-remove-all-overlays)

  (setq major-mode 'metaoopl-mode)
  (setq mode-name "Meta(Oopl)")
  (run-hooks 'metaoopl-mode-hook)
)

(provide 'metaoopl-mode)

;; Find better names for these variables!
(setq META-START-ADJ 1)
(setq META-END-ADJ 0)

;; **********************************************************
;; Meta Construct and Attribute Functionality
;; **********************************************************

;; ==================================================================
;; Basic Meta Block functions
;;  - A block starts with '{' and ends with a matching '}'
;;  - An extent here is NOT to be confused with an XEmacs extent (which
;;    I learned about only after writing this code).  In this code,
;;    an extent is a car.cons cell containing a start and end integer.
;;    Exactly what these numbers refer to depends on the values of
;;    META-START-ADJ and META-END-ADj.  If META-START-ADJ is 0, then the
;;    car portion refers to the location of a '{' token, and if META-END-ADJ
;;    is 0 the cdr portion refers to the location of a '}' token.
;;    If META-START-ADJ is 1, then the car portion refers to one character
;;    AFTER a '{' token, and if META-END-ADJ is -1 the cdr portion refers
;;    to one character BEFORE a '}' token.  Etc.
;;  - The META-START-ADJ and META-END-ADJ variables are NOT meant for user-level
;;    customization - they are private implementation issues to allow us to
;;    explore the best mechanism for overlaying blocks and other regions
;;    of Meta source.
;;
;;  - Some issues:
;;
;;     - If META-*-ADJ = 0, the start and end block tokens are consumed by
;;       the overlay, which means that when the overlay goes invisible, it
;;       is best to provide a before-string of the form '{...}'.  The
;;       downside of this approach is that searches for '{' will not find
;;       the start-of-block token of invisible blocks.
;;
;;     - If META-START-ADJ = 1 and META-END-ADJ = -1, the start and end
;;       block tokens are NOT consumed by the overlay, which means
;;       that when the overlay goes invisible, it is best to provide a
;;       before-string of the form '...'.  This addresses the previous
;;       downside, but does pose a slight problem for another issue.
;;       When scope blocks are collapsed, lines tend to get very long.
;;       It would be nice to be able to insert newlines (and
;;       appropriate indentation) in the before-string marking the
;;       invisible text.  However, with META-END-ADJ = -1, any such
;;       newline would put the '}' on the next line.  Although this
;;       may be what the user wants, it may not be.
;;
;;     - If META-START-ADJ is 1 and META-END-ADJ is 0, we address both
;;       of the previous problems.  It does mean that searches for
;;       '}' will not find the end-of-block tokens of invisible blocks,
;;       but we can solve this with some keys in the overlay keymap.
;; ==================================================================

(defun meta-overlay-start (overlay)
  "Returns the point corresponding to the '}' in a typical meta overlay.
   This is dictated by the overlay start and META-START-ADJ and the special
   nature of overlays in which the last point is not considered part
   of the overlay."
  (- (overlay-start overlay) META-START-ADJ))

(defun meta-overlay-end (overlay)
  "Returns the point corresponding to the '}' in a typical meta overlay.
   This is dictated by the overlay end and META-END-ADJ and the special
   nature of overlays in which the last point is not considered part
   of the overlay."
  (- (overlay-end overlay) META-END-ADJ 1))

(defun meta-prev-scope-extent  ()
   "Returns a car.con atom representing start and end points of the
    scope that ends at or before point.  Initial implementations returned
    the positions of the '{' and '}' characters starting and ending the
    block.  However, newer implementations have generalized this to return
    return META-START-ADJ characters after '{' and META-END-ADJ characters before
    '}' instead.  All other methods relying on this also use the META-ADJ
    variable as appropriate.  This allows us to explore the best means of
    handling blocks.  The only really practical values for META-*-ADJ are 0
    and 1 and maybe -1."

   (interactive)
   (let ((p (point))
         (res nil))
     ;; re-search-backward places point on the '}' character and
     ;; represents the end of the block.
     (if (re-search-backward "}" (point-min) nil)
       (let ((end (point))
	     start
	     )
	 ;; scan-sexps requires that the first argument be one position
	 ;; AFTER a '}' character if we want to find its matching '{'
	 ;; character, and it returns the point at which the matching '{'
	 ;; character resides.
	 (setq start (scan-sexps (+ end 1) -1))

	 ;; Now we create the result cons cell, remembering to
	 ;; adjust start and end by META-*-ADJ
         (setq res
           (cons
	    (+ start META-START-ADJ)
	    (+ end META-END-ADJ)))
          (goto-char p)))
     (message (format "Previous Block: %s" res))
     res))

(defun meta-next-scope-extent  ()
   "Returns a car.con atom representing start and end points
    of the nearest block that starts at or after point.  See
    'meta-prev-scope-extent for additional comments."
   (interactive)
   (let ((p (point))
         (res nil))
     (if (re-search-forward "{" (point-max) nil)
	 ;; start is the point containing '{' (re-search-forward places
	 ;; point one character past this).
         (let ((start (- (point) 1))
	       end
	       )
	   ;; scan-sexps returns the point after the matching '}',
	   ;; so we substract one to get the actual '}' location.
	   (setq end (- (scan-sexps start 1) 1))

	   ;; Now we create the result cons cell, remembering to
	   ;; adjust start and end by META-*-ADJ
           (setq res
                 (cons
                  (+ start META-START-ADJ)
                  (+ end META-END-ADJ)))
           (goto-char p)))
     (message (format "Next Block: %s" res))
     res))

;; ==================================================================
;; Basic Meta Construct functions
;; ==================================================================

(defun meta-line ()
  "Return the contents of the current line (without newline)"
  (buffer-substring-no-properties (line-beginning-position) (line-end-position))
)

(defun meta-parent-block ()
  "Move point to the parent block of the current line."
  (interactive)
  (beginning-of-line)
  (let ((indent (current-indentation)))
    (next-line -1)
    (while (or (>= (current-indentation) indent) (looking-at "[ \t]*$"))
      (next-line -1))))

;; TODO(wmh): With meta-construct-beginning and meta-construct-ancestors in
;; place, there are all sorts of useful methods we can implement:
;;   meta-construct-end:
;;     Go to the end of this construct (which will give us construct extent,
;;     allowing us to collapse entire constructs and do all sorts of things)
;;   meta-find-block-attributes:
;;     Given the extent of a construct, and its horizontal indentation, starting
;;     from the beginning of the construct search forward for lines at exactly
;;     the same indentation level that look like block attributes:
;;       - could be as simple as "ends with :\n"
;;       - could hardcode common attributes like 'scope' and 'comment' (but with
;;         the "ends with :", this probably isn't needed.
;;       - since we know the construct kind, we could maintain an assoc mapping
;;         construct kind to list of secondary attributes, and apply a regexp
;;         to the beginning of the line (but this shouldn't be necessary, since
;;         the only legal thing ending with ":" that can exist at the same indent
;;         level as the construct is a secondary attribute key.
;;     Once we have the block-valued secondary attributes, we can apply filters
;;     to them and narrow any blocks that don't match.  This will allow us to,
;;     for example, show only block attributes for a specific base language or
;;     subset of base languages, etc.

(defun meta-construct-ancestors ()
  """Obtain the construct ancestor list."""
  (let ((looking t) (p (point)) consinfo result)
    (while looking
      (setq consinfo (meta-construct-beginning 1 t))
      (if (eq (point) 1)
          (setq looking nil)
        (meta-parent-block))
      (setq result (cons consinfo result)))
    (goto-char p)
    result))

(defun meta-construct-beginning (parent &optional nomsg)
  "Go to the beginning of a construct.

  Args:
    parents: int
      Number of parents to move up
    nomsg: bool
      If true, do not print a msg
  """
  (interactive "p")
  (if (> parent 1) (meta-parent-block))

  ; We will be using looking-at, so ensure we stay at beginning of line.
  (beginning-of-line)
  (setq goal-column 0)  ; TODO(wmh): does (save-excursion) handle this?

  ; Skip backwards over empty lines
  (while (and (> (point) 1) (looking-at "^[ \t]*$"))
    (next-line -1))

  (let* ((looking t)
        (dent (current-indentation))
        (indent (make-string dent ? ))
        (cons_re (concat "^"
                         indent
                         metaoopl-constructs-re
                         " +"
                         "\\(\\w+\\)"))
        kind if)
    ; We look for the construct at the current indentation level
    (while (and looking (or (>= (current-indentation) dent) (looking-at "[ \t]*$")))
      (if (looking-at cons_re)
          (setq looking nil)
        (next-line -1)))
    ; If not yet found we are now at the next outer indentation level,
    ; and we recurse
    (if looking
        (meta-construct-beginning 1)
      (let ((cons (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
            (id (buffer-substring-no-properties (match-beginning 2) (match-end 2))))
        (if (not nomsg) (message (concat cons " " id)))
        (list cons id (point) indent (line-number-at-pos))))))

; replaced wmh 2013/12/25
(defun meta-construct-beginning-old ()
   "This method moves point to the beginning of the current (or, if
    point is between constructs, previous) construct).  The point
    is placed at the beginning of the primary construct key (so it
    does not represent the absolute beginning of the construct if
    the construct has feature attributes)."
   (interactive)

   (let ((cfs case-fold-search))
     (setq case-fold-search nil)
     (re-search-backward (concat "[^a-zA-Z0-9_]" metaoopl-constructs-re "[^a-zA-Z0-9_]"))
     (setq case-fold-search cfs)
   )
)

(defun metaoopl-complete-construct ()
   (interactive)
   "Assuming point is on a line containing a construct type
    and id, add a COMMENT block, SCOPE block and repeat primary terminator"
   (if (re-search-backward metaoopl-constructs-re)
      (let (
	    (p (point))
            p2
	    cons
	    id
	    )
        ; Point (p) is currently at beginning of construct - search forward
        ; to first space.
	(re-search-forward " ")
        ; Remember this position (p2 is AFTER the first space after the construct)
        (setq p2 (point))
        ; Obtain the construct name
	(setq cons (buffer-substring p (- p2 1)))

        ; Search forward to the end if the identifier.  Note that not all
        ; constructs have primary keys of type 'id', but it will have to do
        ; for now.
        (re-search-forward "[^a-zA-Z0-9_]")
        ; point is after the first non-id-like character
	(setq id (buffer-substring p2 (- (point) 1)))
	(end-of-line)
	(insert (format " COMMENT {\n    /# \n  } SCOPE {\n\n  } %s %s;\n\n" cons id))
        ; How to lowercase a string in emacs? FIX THIS WMH!!
        (re-search-backward "}")
        (downcase-word 1)
	(next-line -3)
	(end-of-line)
      )
   )
)

;; **********************************************************
;; Meta Overlay Functionality
;; **********************************************************

;; ==================================================================
;; Basic overlay functions
;; ==================================================================

(defun meta-prepare-overlays ()
  ;; To be invoked before meta overlays are added to a buffer
  ;;    See http://www.gnu.org/software/emacs/elisp-manual/html_node/elisp_622.html#SEC622
  ;;    and http://www.gnu.org/software/emacs/elisp-manual/html_node/elisp_627.html
  (interactive)
  (set (make-local-variable 'line-move-ignore-invisible) t)

  (let ((invis-map (make-sparse-keymap)))
    (define-key invis-map "\C-n" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE Next") (goto-char (+ (overlay-end ov) 1)) )))
    (define-key invis-map "\C-f" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE Forward") (goto-char (+ (overlay-end ov) 1)) )))
    (define-key invis-map "\C-e" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE EOL") (goto-char (+ (overlay-end ov) 1)) (end-of-line) )))

    (define-key invis-map "\C-p" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE Previous") (goto-char (- (overlay-start ov) 1)) )))
    (define-key invis-map "\C-b" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE Backward") (goto-char (- (overlay-start ov) 1)) )))
    (define-key invis-map "\C-a" '(lambda () (interactive) (let ((ov (meta-overlay-at-point (point)))) (message "HERE BOL") (goto-char (- (overlay-start ov) 1)) (beginning-of-line) )))

    (set (make-local-variable 'meta-invis-keymap) invis-map)
  )

  ;(add-to-invisibility-spec 'meta)
)

(defun meta-remove-overlays-in (from to)
  ;; Removes all 'meta overlays in the specified region
  (interactive "r")
  "Delete meta overlays in region"
  (when (< to from)
    (setq from (prog1 to (setq to from))))
  (let ((ovs (overlays-in from to)))
    (while ovs
      (let ((ov (car ovs)))
        (when (overlay-get ov 'meta)
          (delete-overlay ov)))
      (setq ovs (cdr ovs)))))

(defun meta-remove-all-overlays ()
  ;; Removes all 'meta overlays in the buffer
  (interactive)
  (meta-remove-overlays-in (point-min) (point-max)))

(defun meta-make-overlay (from to)
  "Creating a new meta overlay for the region FROM to TO
   inclusive.  Normally, 'make-overlay' does not include the
   last point, so we add one to 'to'.  In normal operation:
      FROM is one character passed a '{'
      TO is one character before a '}'"
  (interactive "r")
  (let ((overlay (make-overlay from (+ to 1))))
    (overlay-put overlay 'meta t)
    ;(overlay-put overlay 'face '( :foreground "blue" :background "red" ))
    ; we don't bother calling either show or hide in the interests of efficiency
    ; (meta-show-overlay overlay)
    overlay))

(defun meta-current-indentation ()
  "IMPORTANT: The actual definition is in meta-current-indentation2, but is
   not failing gracefully when overlays aren't supported - must fix!!
  "
  (current-indentation)
)

(defun meta-current-indentation2 ()
  "The 'current-indentation function is not sufficiently robust to handle
invisible text properly.  In Meta, if a block has been made invisible and
has been replaced with some marker text (and metaoopl-wrap-collapsed-block-ends
is nil) then the indentation process will break because (forward-line -1)
may place us on a collapsed line, and (current-indentation) will return 1
rather than the actual amount of indentation on the last (hidden) line."
  (let* ((p (point))
	(ov (meta-overlay-at-point p))
	bol
	indent
	)
    (cond
     ( (and ov (overlay-get ov 'invisible))
       ;; We are currently within an invisible meta overlay, so we
       ;; have to do indentation computation ourselves.
       (beginning-of-line)
       (setq bol (point))
       (forward-to-indentation 0)
       (setq indent (- (point) bol))
       (goto-char p)
       indent
     )
     ( t
       ;; Otherwise do normal indentation
       (current-indentation)
     ))
  )
)

(defun meta-hide-overlay (overlay)
  "Do everything appropriate to hide the given overlay"

  (let ( (indentation "") )
    ;; It is a convention that when making an overlay invisible, we set
    ;; the 'invisible property to the name of the package causing the
    ;; invisibility.  Any non-nil value for the 'invisible property will
    ;; result in the text being made invisible.
    (overlay-put overlay 'invisible 'meta)

    (if metaoopl-wrap-collapsed-block-ends
	;; We are to insert a newline and indentation in the invisible
        ;; overlay marker string.  This requires us to determine
        ;; the indentation of the current line.  However, we do NOT
	;; listen to the wrap request if the next non-whitespace
	;; character is a ';' (end of construct).
	(let ((p (point)))
	  ;; We go to one past the '}'
	  (goto-char (+ (meta-overlay-end overlay) 1))
	  (skip-chars-forward " \t")
	  (if (not (eq (following-char) ?\;))
	      (setq indentation (concat "\n" (make-string (meta-current-indentation) ? )))
	  )
	  (goto-char p)
	)
    )

    ;; The 'before-string of an overlay is shown textually at the
    ;; beginning of the overlay but is not "real" (does not influence
    ;; searches, movement, or anything else except visual display).
    ;;   - if META-*-ADJ is 0, the string should probably be '{...}'.
    ;;   - if META-START-ADJ is 1 and META-END-ADJ is -1, the string
    ;;     should probably be '...', possibly with a newline and
    ;;     indentation added.
    ;;   - if META-START-ADJ is 1 and META-END-ADJ is 0, the string
    ;;     should probably be '...}', possibly with a newline and
    ;;     indentation added before or after the '}'
    ;; NOTE: This code can be simplified to a single statement
    ;;   once we've established the best combination of META-START-ADJ
    ;;   and META-END-ADJ.
    (cond
     ( (and (eq META-START-ADJ 0) (eq META-END-ADJ 0))
       (overlay-put overlay 'before-string "{...}") )
     ( (and (eq META-START-ADJ 1) (eq META-END-ADJ -1))
       (overlay-put overlay 'before-string "...") )
     ( (and (eq META-START-ADJ 1) (eq META-END-ADJ 0))
       (overlay-put overlay 'before-string (concat "...}" indentation)))
     ( t
       ;; Unknown situation - how do we throw an exception in Emacs?
       ;; FIX THIS WMH!!!
       (overlay-put overlay 'before-string "{...}"))
    )
    ;; We add a special keymap to the overlay when we hide the text that
    ;; ensures that standard key movements (C-n, C-b, etc.) all really
    ;; treat the text as invisible.
    (overlay-put overlay 'keymap meta-invis-keymap)
  )

  ;; Return the overlay
  overlay)

(defun meta-show-overlay (overlay)
  "Do everything appropriate to show the given overlay.  See meta-hide-overlay"

  ;; We clear the 'invisible property
  (overlay-put overlay 'invisible nil)

  ;; We clear the 'before-string property
  (overlay-put overlay 'before-string nil)

  ;; We clear the keymap so we go back to using the standard keymap
  (overlay-put overlay 'keymap nil)

  ;(overlay-put overlay 'face 'font-lock-comment-face)

  ;; Return the overlay
  overlay)

(defun meta-toggle-overlay-color (overlay)
   "If currently colored, uncolor.  If currently uncolored, color"
   (cond ((null overlay)
          ;; noop
          )
         ((overlay-get overlay 'meta-color)
          (overlay-put overlay 'meta-color nil)
          (overlay-put overlay 'face '(:foreground "red" :background "wheat2"))
          )
         (t
          (overlay-put overlay 'meta-color t)
          (overlay-put overlay 'face '(:foreground "black" :background "wheat"))
          )))

(defun meta-show-overlays (from to)
  ;; Debugging facility - prints all meta overlays in specified region
  (interactive "r")
  (let ((ovs (overlays-in from to)))
    (while ovs
      (let ((ov (car ovs)))
        (when (overlay-get ov 'meta)
          (message (format "Meta: %-5d - %-5d  %s" (overlay-start ov) (overlay-end ov) (if (overlay-get ov 'invisible) "invisible" "visible")))))
      (setq ovs (cdr ovs)))))

;; =================================================================
;; Middle-level meta overlay methods
;; ==================================================================

(defun meta-overlay-after-point (p)
   "Returns the most general meta-specific overlay at or after point.
    Note that multiple overlays can exist after point p, but only those
    with a 'meta propery are considered.  Furthermore, multiple
    meta-specific overlays can exist.  The meta-specific overlay whose
    start point is closest to 'p' is returned."

   (interactive "nPoint: ")

   ;; We obtain all overlays in the buffer after point 'p'.
   ;; If possible, we should try to find a tighter bound than the
   ;; end of buffer!
   (let ((overlays (overlays-in p (point-max)))
	 (min 1000000)
	 (beg (point))
         overlay)
     ;; We look for the meta-specific overlay whose start point
     ;; is closest to p.
     (while overlays
       (let ((ov (car overlays)))
         (if (overlay-get ov 'meta)
	     ;; We have a meta-specific overlay - compute the
	     ;; distance from p to its start point, and if this
	     ;; difference is less than min, update min and overlay
	     (let ((diff (- (overlay-start ov) p)))
	       (if (< diff min)
		   (progn
		     (setq min diff)
		     (setq overlay ov)
		     )
		 )
	       )
	   )
	(setq overlays (cdr overlays))))
     overlay))

(defun meta-overlay-at-point (p)
   "Returns the most specific meta-specific overlay that covers point 'p'.
    Note that multiple overlays can exist at point, but only those
    with a 'meta propery are considered.  Furthermore, multiple
    meta-specific overlays are possible due to nested scopes.  In such
    situations, it is the overlay that covers the smallest region (including
    'p') that is returned"

   (interactive "nPoint: ")
   (let ((overlays (overlays-at p))
	 (min-width 100000)
         overlay)
     (while overlays
       (let ((ov (car overlays)))
	 (if (overlay-get ov 'meta)
	     ;; We have a meta-specific overlay - compute the
	     ;; "width" of the overlay and compare it with min-wdith.
	     ;; If less, update width and overlay
	     (let ((width (- (overlay-end ov) (overlay-start ov))))
	       (if (< width min-width)
		   (progn
		     (setq min-width width)
		     (setq overlay ov))))))
       (setq overlays (cdr overlays)))
     overlay))

(defun meta-prev-overlay ()
   "Returns the overlay to the block that ends at or before point.
    If an overlay does not exist for this block, one is created,
    without affecting its show/hide status."
   (interactive)
   ;; We have to do something a little special here that is not
   ;; necessary in 'meta-next-overlay.  If we are currently
   ;; inside an overlay, we return it, otherwise we return
   ;; the previous scope.  This makes hide/show work properly.
   (let ((overlay (meta-overlay-at-point (point))))
     (if (null overlay)
	 (let ((ext (meta-prev-scope-extent)))
	   (setq overlay (meta-overlay-at-point (car ext)))
	   (if (not overlay)
	       (setq overlay (meta-make-overlay (car ext) (cdr ext))))))
     overlay))

(defun meta-next-overlay ()
   "Returns the overlay associated with the closest block that starts
    at or after the current point. If an overlay does not exist for this
    block, one is created, without affecting its show/hide status."

   (interactive)
   (let* ((ext (meta-next-scope-extent))
          (overlay (meta-overlay-at-point (car ext))))
      (if (not overlay)
         (setq overlay (meta-make-overlay (car ext) (cdr ext))))
      overlay))

(defun meta-toggle-prev-overlay-visibility ()
  (interactive)
  (let ((overlay (meta-prev-overlay)))
    (if (overlay-get overlay 'invisible)
        (meta-show-overlay overlay)
      ;; else
      (meta-hide-overlay overlay))
    ;; We place oursevles on the '{' (but remember that if
    ;; META-START-ADJ is less than 1, the '{' token is not "real" when
    ;; the block is invisible, so the point will not appear on the '{'
    ;; in such situations).
    (goto-char (meta-overlay-start overlay))))

(defun meta-toggle-next-overlay-visibility ()
  (interactive)
  (let ((overlay (meta-next-overlay)))
    (if (overlay-get overlay 'invisible)
        (meta-show-overlay overlay)
      ;; else
	(meta-hide-overlay overlay))
    ;; We move ourselves to the '}' (but remember that if
    ;; META-START-ADJ is less than 1, the '}' token is not "real" when
    ;; the block is invisible, so the point will not appear on the '}'
    ;; in such situations).
    (goto-char (meta-overlay-end overlay))))

(defun meta-toggle-prev-overlay-color ()
  (interactive)
  (meta-toggle-overlay-color (meta-prev-overlay)))

(defun meta-toggle-next-overlay-color ()
  (interactive)
  (meta-toggle-overlay-color (meta-next-overlay)))

(define-key metaoopl-mode-map [(control \,)] 'meta-toggle-prev-overlay-color)
(define-key metaoopl-mode-map [(control \.)] 'meta-toggle-next-overlay-color)
(define-key metaoopl-mode-map [(control \<)] 'meta-toggle-prev-overlay-visibility)
(define-key metaoopl-mode-map [(control \>)] 'meta-toggle-next-overlay-visibility)


;; This is a start on getting base-language-specific font-lock coloring
;; to work when we go into a SCOPE block.  We could augment the movement
;; methods to detect entry into (and exit from) such blocks, then
;; switch the major mode to a base-language appropriate mode, fontify
;; the region from the beginning to end of the block, then switch back
;; to the appropriate meta-level mode.  Alternatively, we can just
;; fontify every base-language specific block every time fontification
;; is requested.
;;
;; Problems have arisen during attempts to get this to work:
;;   font-lock-fontify-buffer is too broad
;;   font-lock-fontify-block complains of invalid args (markerp issue)
;;   font-lock-fontify-region seems like a perfect fit, but was posing
;;     similar problems, or wasn't fontifying properly
;;   font-lock-fontify-syntactically-region is identified as the place
;;     in which the markerp error was occuring - the 'font-lock-cache-position'
;;     variable was nil but was being passed to 'marker-position)
;;
(defun meta-fontify-perl-blocks ()
  (interactive)
  (let ((p (point)))
    (goto-char (point-min))
    (while (re-search-forward "SCOPE<Perl>" (point-max) t)
      ;; (message (format "Point is %d" (point)))
      (meta-fontify-perl-block)
    )
    (goto-char p)
  )
)

(defun meta-fontify-perl-block ()
  ;; Fontify the next block as if it were perl code
  (let*  ( (p (point))
	  (beg (- (re-search-forward "{") 2))
	  (end (scan-sexps beg 1))
	  )
     (message (format "START is %d  END is %d" beg end))

     ;; Switch to Perl mode
     (cperl-mode)
     ;(font-lock-set-defaults)

     ;; Advance to the beginning of the next line
     (goto-char beg)
     (end-of-line)
     (forward-char 1)

     ;; Set some variables to that the following functions will work
     (setq font-lock-cache-state nil)
     (setq font-lock-cache-position (make-marker))
     ;(set-marker font-lock-cache-position (point-min))
     (set-marker font-lock-cache-position (point))
     (setq font-lock-cache-state (parse-partial-sexp (point-min) (point-min)))
     (print font-lock-cache-state)


     (let ((state (parse-partial-sexp (marker-position font-lock-cache-position) (point) nil nil
				      font-lock-cache-state)))
         (print state)
     )

     ;; This poses problems (unfontifies Meta code outside the region requested)
     ;; (font-lock-unfontify-region (point) end)

     ;; We are now at the beginning of a line, as requested by 'font-lock-fontify-syntactically-region
     (font-lock-fontify-syntactically-region (point) end t)

     ;; Switch back to Meta mode
     (metaoopl-mode)
     (goto-char p)
  )
)

(defun meta-collapse-construct ()
  "Collapse all block-attributes within the current construct"
  (interactive)
  (let ((p (point))
	done
	ov
       )
    (while (not done)
      (re-search-forward "[{;]" (point-max) t)
      (if (eq (preceding-char) ?\;)
	  (setq done t)
	(forward-char -2)
	(setq ov (meta-hide-overlay (meta-next-overlay)))
	(goto-char (+ (overlay-end ov) 1))
      )
    )
    (goto-char p)
    (beginning-of-line)
  )
)
